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g; 

23: 
24: 

d; 

25: 
26: 
ing; 

27 : 

28 : 
29: 
30 : 

31: // TODO: Construct Subclass - this should not be needed! 

32: function Construct Subclass (AClass : TClass; AParams: array of 
TObject) : TObject; 

33: // TODO: Const ructComponent - this should not be needed! 

34: function ConstructComponent (AClass : TComponentClass ; AOwner: 
TComponent = nil) : TComponent; 

35: 

36: function I sProxyClass (AInstance : TObject) : Boolean; overload; 
37: function IsProxyClass (AClass : TClass): Boolean; overload; 
38 : 

39: // TODO: ChangeToProxyClass, this can't work like the old way so w 
ill 

this do? 

40: procedure ChangeToProxyClass (AInstance : TObject {; TClass argument} 

) ; 

overload; deprecated; 

41: procedure ChangeToProxyClass (AClass : TClass); overload; 
42 : 

43: 

44 : 

45 : 
46: 

47 : 

48 : 
49: 

50 : 
nt ; 

Operation: TOperation) ; 

51 : 

52: procedure Savelt; 
53: 

54: type 



***************************************************** 
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unit Borland. Vcl . Design . Proxies; 

interface 

uses 

System. Collections, System. Reflection, System. Reflection . Emit , 
System. Globalization, Typlnfo, Classes, SysUtils; 

//!! APIs have changed quite a bit 

function CreateSubClass (AAncestor : TClass; const AClassName: strin 

const AUnitName: string = ' ') : TClass; 
procedure DestroySubClass (AInstance : TObject); overload; deprecate 

procedure DestroySubClass (AClass : TClass); overload; 

procedure RenameSubClass (AInstance : TObject; const AClassName: str 

const AUnitName: string = ''); overload; deprecated; 
procedure RenameSubClass (AClass : TClass; const AClassName: string; 
const AUnitName: string = ' ') ; overload; 



function CreateSubClassMethod (AInstance : TObject; 

const AMethodName: string) : TMethodCode; 
procedure RenameSubClassMethod (AInstance : TObject; 

const AMethodCode: TMethodCode; const AMethodName: string); 
procedure DestroySubClassMethod (AInstance : TObject; 

const AMethodCode: TMethodCode); 

procedure HandleNot if icat ion ( Sender : TObject; AComponent : TCompone 



55: EProxyError = class (Exception) ; 
56: 

57: implementation 
58: 

59: uses System. Runtime . InteropServices; 
60: 

61: type 

62: TProxylntercept = class (TObject, IProxySystemSupport , 
IP roxyTyp Info Support ) 

63: strict private 

64: function GetMethodAddress (AClass : TClass; const AName : string; 

out ACode: TMethodCode) : Boolean; 
65: 

66: function GetMethodProp (AInstance : TObject; APropInfo: TPropInf 

o; 

out AMethod: TMethod) : Boolean; 

67: function SetMethodProp (AInstance : TObject; APropInfo: TPropInf 

o; 

const AMethod: TMethod) : Boolean; 

68: function GetUnitName (ATypeInf o : TTypelnfo; out AUnitName : 
string) : Boolean; 

69: end; 

70: 

71: TInstanceRef = class (TObject ) 

72 : public 

73: Props: Hashtable; 

74: constructor Create; 

75: end; 
76: 

77: TProxyType = class (TypeDelegator) 

78: strict private 

79: class var 

80: FAssemblyBuilder : AssemblyBuilder ; 

81: FModuleBuilder : ModuleBuilder ; 

82: FProxyTypelndex : Integer; 

83: FProxylntercept : TProxylntercept; 

84: FRootMetaType : System. Type; 

85: FRootHandleField : Fieldlnfo; 

86: FRootParentField: Fieldlnfo; 

87: FProxyNot if icat ionMethod : Methodlnfo; 

88: FSendNotif icationMethod: Methodlnfo; 

89: FProxies: Hashtable; 

90: FInstances: Hashtable; 

91: 

92: var 

93: FClassName: string; 

94: FUnitName: string; 

95: FMethods: Hashtable; 
96: 

97 : strict protected 

98: class procedure CreateBoolAttribute (ATypeBuilder : TypeBuilder; 

99: AAttribute: System. Type; AValue : Boolean = True); 

100: class function CreateMetaSubType (ABaseType, AType : System. Type 

} 

101: ATypeBuilder: TypeBuilder): System. Type; 

102: class procedure CodeGenConstructors (ABaseType : System. Type; 
ATypeBuilder: TypeBuilder); 

103: class procedure CodeGenNot if icat ion (ABaseType : System. Type; 
ATypeBuilder: TypeBuilder); 

104: class function FindRealType (var AType: System. Type) : Boolean; 

105: public 

106: class constructor Create; 

107: constructor Create (Ancestor : System. Type; const AClassName, 
AUnitName: string); 
108 : 

10 9: // delegator work 

110: function get_FullName : string; override; 
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function get_Name : string; override; 
function get_Name space : string; override; 

// support for the public functions 

class function FindProxy (AInstance : TObject) : TProxyType; 
function CreateMethod (const AMethodName : string): TMethodCode; 
procedure RenameMethod (const AMethodCode: TMethodCode; const 



AMethodName: string); 
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AClassName 
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AClassName: string; 



procedure DestroyMethod (const AMethodCode: TMethodCode); 

// type versions of the public functions 

class function IsSubTyped (AType : System. Type) : Boolean; 
class function CreateSubType (ABaseType : System. Type; const 

string; 

const AUnitName : string = ' ') : System. Type; 
class procedure ChangeToProxyType (AType : System . Type ) ; 
class procedure DestroySubType (AType : System . Type ) ; 
class procedure RenameSubType (AType : System. Type; const 
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130 
string; 
131: 



const AUnitName: string = 



) ; 



// support functions for TProxylntercept 

class function GetMethodAddress (AClass : TClass; const AName : 
out ACode: TMethodCode) : Boolean; 

class function GetMethodProp (AInstance : TObject; APropInfo: 
TPropInfo; out AMethod: TMethod) : Boolean; 

132: class function SetMethodProp (AInstance : 

TPropInfo; const AMethod: TMethod) : Boolean; 
133: class function GetUnitName (ATypeInf o : TTypelnfo; out AUnitName 



TObject; APropInfo : 



string) 

134 : 

135 : 



Boolean; 

class procedure HandleNot if icat ion ( Sender : TObject; AComponent 



string 



TComponent; Operation: TOperation) ; static; 
136: 

137: // onetime snapshot of Proxies' scratch assembly 

13 8: // WARNING: once you ' Savelt ' ; you can't create anymore proxy 
classes /types 

139: class procedure Savelt; 

14 0: end; 
141 
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) ; 
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150 
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156 

157 
override; 

158: 
it : 

Boolean) : 

159: 
n) : 

Boolean; override; 
160: function get_DeclaringType : System. Type; override; 

161: function get_MemberType : MemberTypes; override; 



TObjects = array of TObject; 
TMethodProxy = class (TMethodCode) 
strict private 

FProxyType: TProxyType; 
FName : string; 
public 

constructor Create (AProxyType : TProxyType; const AName: 

procedure Clear; 

// TMethodProxy stuff 
procedure Rename (Value : string); 
function get_ProxyType : TProxyType; 

property ProxyType: TProxyType read get_ProxyType ; 
// Memberlnfo stuff 

function GetCustomAttributes (AInherit : Boolean): TObjects; 
function GetCustomAttributes (AttributeType : System. Type; Inher 

TObjects; override; 

function IsDefined (AttributeType : System. Type; Inherit: Boolea 
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function get_Name : string; override; 

function get_Ref lectedType : System. Type; override; 

property DeclaringType : System. Type read get_DeclaringType; 

property MemberType: MemberTypes read get_MemberType; 

property Name: string read get_Name; 

property Ref lectedType : System. Type read get_Ref lectedType; 
end; 

{ TProxylntercept } 



function TProxylntercept . GetMethodAddress (AClass : TClass; const 
string; out ACode : TMethodCode) : Boolean; 
17 3: begin 
174: Result 
end; 



function TProxylntercept . GetMethodProp (AInstance : TObject; APropIn 



TProxyType. GetMethodAddress (AClass, AName, ACode) ; 

175 : 
176; 
177 : 
fo: 

TPropInfo; out AMethod: TMethod) : Boolean; 
178: begin 

17 9: Result := TProxyType . GetMethodProp (AInstance, APropInfo, AMethod 
) ; 

180: end; 
181: 

182: function TProxylntercept . SetMethodProp (AInstance : TObject; APropIn 
fo: 

TPropInfo; const AMethod: TMethod) : Boolean; 
183: begin 

184: Result := TProxyType . SetMethodProp (AInstance, APropInfo, AMethod 
) ; 

185: end; 
186: 

187: function TProxylntercept . GetUnitName (ATypelnfo : TTypelnfo; out 
AUnitName: string) : Boolean; 
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begin 

Result := TProxyType . GetUnitName (ATypelnfo, AUnitName); 
end; 

{ TInstanceRef } 

constructor TInstanceRef . Create; 
begin 

inherited; 

Props := Hashtable . Create; 
end; 



{ TProxyType } 
const 

STestAssemblyName = ' VclDesignTime_ProxyAssembly ' ; 
STestModuleName = ' VclDesignTime_ProxyModule * ; 
STestTypeName = ' Borland . Vcl . DesignTime . ProxyType%d * ; 
STestFileName = STestAssemblyName + *.dll'; 

var 

EchoLevel : Integer = 0; 
{procedure EchoType (const APrefix: string; AType : System. Type; 



AMaxDepth: Integer = 4) ; 
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begin 

Inc (EchoLevel) ; 
try 

WriteLn (APrefix, ' *****^*********^*'); 
if EchoLevel > AMaxDepth then 

WriteLn (APrefix, ' IS TOO DEEP') 
else 

if AType = nil then 



221: WriteLn (APref ix, ' IS NIL') 

222: else 

223: begin 

224: WriteLn (APref ix, '.Name = \ AType . Name) ; 

225: WriteLn (APref ix, '.FullName = ', AType . FullName) ; 

226: WriteLn (APref ix, '.Assembly = ', AType .Assembly . FullName) ; 

221: WriteLn (APref ix, ' .AssemblyQualifedName = \ 
AType . AssemblyQualif iedName) ; 

228: WriteLn (APref ix, ' .NameSpace = \ AType . Name Space ) ; 

229: WriteLn (APref ix, '.Attributes = ', 
System. Enum (AType .Attributes) .ToString) ; 

230: WriteLn (APref ix, ' .MemberType = \ 
System. Enum (AType .MemberType) .ToString) ; 

231: try 

232: WriteLn (APref ix, '.TypeHandle = ', AType . TypeHandle .Valu 
e) ; 

233: except 

234: on E: Exception do 

235: WriteLn (APref ix, '.TypeHandle = ', E. Message); 

236: end; 

237: try 

238: WriteLn (APref ix, '.ClassName = ', AType . ClassName) ; 

239: WriteLn (APref ix, ' . Classinf o . Name = ', 
AType . Classlnfo .Name) ; 

24 0: except 

241: on E: Exception do 

242: begin 

243: WriteLn (APref ix, '.ClassName = ', E. Message); 

244: WriteLn (APref ix, '. Classinf o . Name = ', E. Message); 

245: end; 

24 6: end; 

247: if AType. Module <> nil then 

248: WriteLn (APref ix, Module . Name = AType . Module . Name ) ; 

24 9: if AType . BaseType <> nil then 

250: EchoType (APref ix -h '.BaseType', AType . BaseType, AMaxDept 
h) ; 

251: if AType . DeclaringType <> nil then 

252: EchoType (APref ix + '.DeclaringType', AType . DeclaringType 
AMaxDept h) ; 

253: if AType . UnderlyingSystemType <> nil then 

254: EchoType (APref ix + '.UnderlyingSystemType', 
AType . UnderlyingSystemType, AMaxDepth) ; 

255: end; 

256: finally 

257: Dec (EchoLevel) ; 

258: if EchoLevel < 0 then 

259: begin 

260: WriteLn ('####################### How did that happen? 
#######################') ; 

2 61: EchoLevel := 0; 

2 62: end; 

263: end; 

264 : end; } 
265: 

266: resourcest ring 

267: SNoHandleNotif ication = 'Could not find 
Borland . Vol . Design . Proxies . Unit . HandleNot if ication ' ; 

268: SNoSendNotif ication = 'Could not find 
Borland . Vcl .Classes . Unit . SendNot if ication ' ; 

269: SCouldNotFindBaseMeta = 'Could not find BaseMetaClass ' ; 

270: SCouldNotFindTypeHandle = 'Could not find 
RootMet aClass . FInstanceTypeHandle ' ; 

271: SCouldNotFindParent = 'Could not find RootMetaClass . FClassParent 

r 

272: SCouldNotFindConstructor = 'Could not find BaseType . Constructor ' 

r 

273: SCouldNotFindMetaConstructor = 'Could not find 



MetaClass . Constructor ' ; 
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SAlreadyProxy = 'Type is already a proxy*; 
STypeNotSubType = 'Type is not a subtype'; 
SMethodNotMethodProxy = 'Method is not a method proxy'; 



class constructor TProxyType . Create; 
var 

LAs s emb 1 y Name : As s emb 1 yName ; 
LProxiesUnitType : System. Type; 
LClassesUnitType : System. Type; 
begin 

// a place to work 

FProxies := Hashtable . Create; 

FInstances := Hashtable . Create; 



// create our scratcharea assembly and module 
LAssemblyName := AssemblyName . Create; 
LAs s emb 1 yName . Name := S Te s tAss emb 1 yName; 
FAssemblyBuilder := 
AppDomain . CurrentDomain . Def ineDynamicAssembly (LAssemblyName, 
AssemblyBuilderAccess . RunAndSave) ; 

2 93: FModuleBuilder := 
FAssemblyBuilder . Def ineDynamicModule ( STestModuleName, STestFileName, 
True) ; 
294: 

2 95: // the following is need simply to keep the compiler from 
smartlinking certain functions into oblivion 



296 
297 
298 

rt) ; 
299 
300 
301 
302 
303 



if FProxyTypelndex < 0 then 
begin 

Borland. Vcl . Design . Proxies . HandleNotification (nil, nil, opinse 

Classes . SendNot if icat ion (nil, nil, opinsert) ; 
end; 



// find the sendnot if icat ion function over in Classes 
LProxiesUnitType := 
TypeOf (EProxyError ) .Assembly . Get Type ( ' Borland .Vcl . Design . Proxies . 
Unit ' ) ; 

304: FProxyNotif icationMethod := 
LProxiesUnitType . GetMethod ( ' HandleNot if icat ion ' , 

305: BindingFlags . Public or BindingFlags . Stat ic or 

BindingFlags . InvokeMethod) ; 
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if FProxyNotif icat ionMethod = nil then 

raise EProxyError . Create ( SNoHandleNot if icat ion) ; 



// find the sendnotif ication function over in Classes 
LClassesUnitType := 
TypeOf (Classes . TOperation) .Assembly . GetType ( ' Borland. Vcl . Classes , 
Unit ' ) ; 

311: FSendNotif icationMethod := 
LClassesUnitType . GetMethod ( ' SendNotif ication ' , 

312: BindingFlags . Public or BindingFlags . Static or 

BindingFlags . InvokeMethod) ; 
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if FSendNotif icat ionMethod = nil then 

raise EProxyError . Create ( SNoSendNot if icat ion) ; 

// wedge into System and Typlnfo 
FProxylntercept := TProxy Intercept . Create ; 

Borland. Delphi . System. ProxySystemSupport := FProxylntercept; 
ProxyTypInf oSupport := FProxylntercept; 
end; 

constructor TProxyType . Create (Ancestor : System. Type; const AClassN 

AUnitName: string); 
begin 

inherited Create (Ancestor) ; 
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FClassName := AClassName; 
FUnitName : = AUnitName; 
FMethods := Hasht able . Create; 
end; 



function 
begin 

Result 
end; 

function 
begin 

Result 
end; 

function 
begin 

Result 
end; 



TProxyType . get_Name : string; 
:= FClassName; 

TProxyType . get_FullName : string; 
:= FUnitName + * . ' + FClassName; 

TProxyType . get_Namespace : string; 
:= FUnitName; 



class 
begin 

// while FindRealType will 
// callee won * t see it 
Result := FindRealType (AType) 
end; 



function TProxyType . I sSubTyped (AType : System. Type) : Boolean; 

change the AType we passed it the 



class procedure TProxyType . CreateBoolAttribute (ATypeBuilder : 



System. Type; AValue : Boolean) 
Constructorinf o; 



TypeBuilder ; 
354: AAttribute 
355: var 

356: LAttributeConstructor 

357 : begin 

358: LAttributeConstructor := 
AAttribute . GetConstruct or ( [TypeOf (AValue) ] ) ; 
359: 

ATypeBuilder . SetCustomAttribute (CustomAttributeBuilder . Create ( 
LAttributeConstructor, [AValue] ) ) ; 

360 : end; 

361 : 

362: class function TProxyType . CreateMetaSubType (ABaseType, 
System. Type; ATypeBuilder: TypeBuilder): System. Type; 



AType : 
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var 

LBaseType : System. Type; 
LTypeBuilder : TypeBuilder; 
LBaseConstructor : Constructorinf o; 
LRootMetaType : System. Type; 
LRootHandleField: Fieldlnfo; 
LRootParentField: Fieldlnfo; 
LConstructorBuilder : ConstructorBuilder ; 
LILGenerator : ILGenerator; 
LBaselnstanceField: Fieldlnfo; 
LInstanceField : Fieldlnfo; 

LTypeConstructorBuilder : ConstructorBuilder; 
begin 

// find the base metatypes 

LBaseType := ABaseType . GetNestedType ( ' @Meta ' + ABaseType . Name) 
if LBaseType = nil then 

raise EProxyError . Create ( SCouldNotFindBaseMeta) ; 

// found the root metatype yet? 
if FRootMetaType = nil then 

begin 

// chase up the metaclass parentage to find the root 

FRootMetaType := LBaseType; 

while FRootMetaType . BaseType <> nil do 



389: begin 

390: if FRootMetaType.BaseType = TypeOf (TOb ject ) then 

391: break; 

3 92: FRootMetaType := FRootMetaType.BaseType; 

3 93: end; 

394: 

395: // look for a couple of fields that we will need 

3 96: FRootHandleField := FRootMetaType . GetField FInstanceTypeHandl 

BindingFlags . Nonpublic or BindingFlags . Instance) ; 
397: if FRootHandleField = nil then 

398: raise EProxyError . Create ( SCouldNotFindTypeHandle ) ; 

399 : 

400: FRootParentField := FRootMetaType . GetField (' FClassParent ' , 

BindingFlags . Nonpublic or BindingFlags . Instance) ; 
401: if FRootParentField = nil then 

402: raise EProxyError . Create ( SCouldNotFindParent ) ; 

403: end; 
404 : 

405: // add a metatype for this type we are working on and add a fiel 

d 

to the type 

4 06: LTypeBuilder := ATypeBuilder . Def ineNestedType ( ' @Meta ' + 
ATypeBuilder .Name, 

4 07: TypeAttributes .NestedPublic or TypeAttributes . Bef oreFieldlnit , 

LBaseType) ; 
408 : 

40 9: // add attribute or two 
410 : CreateBoolAttribute (LTypeBuilder, 
TypeOf ( System. CLSCompliantAttribute) ) ; 

411 : CreateBoolAttribute (LTypeBuilder, 
TypeOf ( System. Runtime . Inter op Services . ComVisibleAttribute ) ) ; 
412 : 

413: // create our own instance field 

414: LInstanceField := LTypeBuilder . DefineField @ Instance ' , 
LTypeBuilder, 

415: FieldAttributes .Public or FieldAttributes . Static) ; 

416: 

417: // build constructor 

418: LConst ruct orBuilder := 
LTypeBuilder . Def ineConstructor (Met hodAt tributes . Public or 
MethodAttributes . HideBySig, 

419: CallingConventions . Standard, []); 

420: LILGenerator := LConstructorBuilder . Get ILGenerator ; 
421: with LILGenerator, Opcodes do 
422: begin 

423: // CODE TO BE GENERATED 

424: // inherited Create; 

425: // FInstanceTypeHandle := Self . TypeHandle; 

426: // FClassParent := { ParentClass }. @ Instance; // only codegen if 

parentclass has one 
427 : 

428: LBaseConstructor := LBaseType . GetConstructor ([]) ; // find the 

base ' s create 
429: if LBaseConstructor = nil then 

430: raise EProxyError . Create ( SCouldNotFindConstructor ) ; 

431: Emit (Ldarg_0) ; // pus 

h 

the instance 

432: Emit (Call, LBaseConstructor); // emit a call to the pare 

nt 

constructor 
433: 

434: Emit (Ldarg_0) ; // pus 

h 



the instance 

435: Emit (Ldtoken, AType) ; // push the hand 

le 

of the type 

436: Emit(Stfld, FRootHandleField) ; // store the handle in th 

e 

root's field 
437 : 

438: // see if the base metatype has an instance field yet 

439: LBaselnstanceField := LBaseType . GetField (' @ Instance ' , 

BindingFlags . Public or BindingFlags . St at ic ) ; 
440: if LBaselnstanceField <> nil then 

441: begin 

442: Emit (Ldarg_0) ; // pus 

h 

the instance 

443: Emit (Ldsf Id, LBaselnstanceField); // get t 

he 

parent info 

444: Emit(Stfld, FRootParentField) ; // store it i 

nto 

root field 
445: end; 
446: 

447 : Emit (Ret) ; 

// fini 
44 8: end; 
449: 

450: // now create the class constructor 

451: LTypeConstructorBuilder := LTypeBuilder . Def ineTypelnit ializer ; 
452: LILGenerator := LTypeConst ructorBuilder . Get ILGenerator ; 
453: with LILGenerator, Opcodes do 
4 54: begin 

4 55: // CODE TO BE GENERATED 

456: // ^Instance := @Meta { Class }. Create; 

457 : 

458: Emit(Newobj, LConstructorBuilder) ; // create an instance of 

the metaclass 

459: Emit (Stsf Id, LInstanceField) ; // store it in our 

instance field 
460: 

461: Emit (Ret); 

// fini 
4 62: end; 
463: 

4 64: // before we leave we had better actually create the type hadn't 
we 

4 65: Result := LTypeBuilder . CreateType; 
466: end; 
467 : 

4 68: class procedure TProxyType . CodeGenConstructors (ABaseType : 
System. Type; ATypeBuilder : TypeBuilder) ; 



4 69: var 

470: LConstructors : array of Constructorinf o; 

471: LParameters : array of Parameter Info; 

472: LParamTypes : array of System. Type; 

473: LConstructorBaseType : System. Type; 

474: LConstructorBuilder: ConstructorBuilder ; 

475: LILGenerator: ILGenerator; 

47 6: LConstructorNdx, LParameterNdx : Integer; 

477 : begin 

478: LConstructorBaseType := ABaseType; 

47 9: while LConstructorBaseType <> nil do 

480: begin 
481: 



482 
483 
484 
485 
486 



// see if it has any constructors 

LConstructors := LConstructorBaseType . GetConstructors ; 

if Length (LConstructors ) <> 0 then 

begin 

for LConstructorNdx := Low (LConstructors ) to 



High (LConstructors) do 



do 



begin 

with LConstructors [LConstructorNdx] 
begin 

// copy the param and in turn their types 
LParameters : = GetParameters ; 

SetLength (LParamTypes, Length (LParameters ) ) ; 
for LParameterNdx := Low (LParameters ) to High (LParameter 



487 
488 
489 
490 

491 

492 

493 
s) 
do 

4 94: LParamTypes [LParameterNdx] := 

LParameters [LParameterNdx] . ParameterType; 
495: 

496: // construct a constructor builder 

4 97: LConstructorBuilder := 

ATypeBuilder . DefineCons true tor (Attributes, 
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499 
500 
501 
502 
503 
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CallingConvention, LParamTypes) ; 
end; 

// lets write some code 

LILGenerator := LConstructorBuilder . Get ILGenerator; 

with LILGenerator, Opcodes do 

begin 

// CODE TO BE GENERATED 

// inherited Create ({arg count depends on parentclass } ) 



push instance 

509: 

510: 
// 

push params 

511 : 

1 

the base ctr 

512 : 

513 : 

// fini 
514 
515 
516 
517 
518 
519 
520 
521 
522 
523 
524 
525 
526 



Emit (Ldarg_0) ; 



for LParameterNdx := 1 to Length (LParameters ) do 
Emit (Ldarg_S, LParameterNdx) ; 



Emit (Call, LConstructors [LConstructorNdx] ) ; 



Emit (Ret) ; 



// 



// cal 



end; 
end; 

// done 
break; 
end; 

// move up a level 
LConstructorBaseType 
end; 
end; 



LConstructorBaseType . BaseType; 



class procedure TProxyType . CodeGenNotif ication (ABaseType : 
System. Type; ATypeBuilder: TypeBuilder) ; 
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var 

LParamTypes: array of System. Type; 
LBaseNot if icat ionMethod : Methodinf o; 
LMethodBuilder : MethodBuilder ; 
LILGenerator: ILGenerator; 
LLabel : System. Reflection . Emit . Label; 
begin 

// get the param list ready 
SetLength (LParamTypes, 2); 



536: LParamTypes [ 0 ] := TypeOf (Classes . TComponent ) ; 

537: LParamTypes [1] := TypeOf (Classes . TOperation) ; 
538: 

539: // see if we can find a notification method to call 

540: LBaseNotif icationMethod := ABaseType . GetMethod (' Notification ' , 

541: BindingFlags . Public or BindingFlags . Nonpublic or 
BindingFlags . Instance or 

542: BindingFlags . InvokeMethod, nil, LParamTypes, nil); 

543: if LBaseNotif icationMethod <> nil then 

544: begin 
545: 

546: // create a builder 

547: with LBaseNotif icationMethod do 

548: LMethodBuilder := ATypeBuilder . Def ineMethod (Name, 

54 9: MethodAttributes . FamORAssem or MethodAttributes .Virtual, 

550: CallingConvent ion, ReturnType, LParamTypes); 

551 : 

552: // let's write some code! 

553: LILGenerator := LMethodBuilder . Get ILGenerator; 

554: with LILGenerator, Opcodes do 

555: begin 

556: // CODE TO BE GENERATED 

557: // Borland. Vcl .Design. Proxies .HandleNotification (Self , 
AComponent, AOperation) ; 

558: // if Borland. Vcl . Classes . SendNotification (Self , AComponent, 

AOperation) then 

559: // inherited Notification (AComponent , AOperation); 
560: 

561: Emit (Ldarg_0) ; // 



push instance 

5 62 : Emit (Ldarg_l) ; 

component reference 

5 63 : Emit (Ldarg_2) ; 

happening to it 

564: Emit (Call, FProxyNotif icationMethod) ; 

s 

not if y-wedge 
565: 

566 : Emit (Ldarg_0) ; 

push instance 

567 : Emit (Ldarg_l) ; 

component reference 

568 : Emit (Ldarg_2) ; 

happening to it 

569: Emit (Call, FSendNotif icationMethod) ; 

sendnotif ication 

570 : 

571: LLabel := DefineLabel; 

572 : Emit (Brf alse_S, LLabel) ; 



// push 
// push what is 
// call the proxy' 

// 

// push 
// push what is 
// call classes' 

// if result is 



false then . . . 
573: 

57 4: Emit (Ldarg_0) ; // 



push instance 

575: Emit (Ldarg_l) ; // push 

component reference 

576: Emit (Ldarg_2 ) ; // push what is 

happening to it 

577: Emit (Call, LBaseNotif icationMethod) ; // call the 



base ' s method 
578: 

57 9: MarkLabel (LLabel) ; // 

. . . jump to here 



580 : 
581: 



Emit (Ret) ; 



// fini 

582: end; 

583: end; 

584: end; 
585: 

586: class function TProxyType . FindRealType (var AType : System. Type) : 
Boolean; 

5 8 7: begin 

588: // just in case were given a proxy type lets find the real type 

58 9: if AType is TProxyType then 

590: AType := AType . UnderlyingSystemType; 

591 : 

592: // see if we can find it in our list 

5 93: Result := FProxies . Contains (AType) ; 

594: end; 
595: 

5 96: class function TProxyType . CreateSubType (ABaseType : System. Type; 

5 97: const AClassName: string; const AUnitName : string = ' *) : 
System. Type; 

5 98: var 

599: LTypeBuilder : TypeBuilder; 

60 0: LMetaType: System. Type; 

601: LMetaConstructor : Constructorinf o; 

602: LProxyType: TProxyType; 

603: LNewType: System. Type; 

604: begin 

605: // find the real type... if we have been handed a proxytype, 
instead of 

606: // a ' realtype ' , then FindRealType will modify ABaseType so th 
at 

it 

607: // points to the proxy's UnderlyingSystemType. 

60 8 : FindRealType (ABaseType) ; 

609: 

610: // create a type builder ...remember each type must have 

a 

unique name 

611: LTypeBuilder := FModuleBuilder . DefineType (Format ( STestTypeName, 
[FProxyTypelndex] ) , TypeAttributes . Public, ABaseType); 

612: Inc (FProxyTypelndex) ; 
613: 

614: // find the first ancestor class that has constructors and copy 
them 

615: CodeGenConstructors (ABaseType, LTypeBuilder); 
616: 

617: // TODO: If the type is a TComponent desendent then we need to h 
ook 

notification 

618: CodeGenNotification (ABaseType, LTypeBuilder); 
619: 

620: // quick make the type before it slips away again :-) 

621: LNewType := LTypeBuilder . CreateType ; 

622: LProxyType := TProxyType . Create (LNewType, AClassName, AUnitName) 
' 623: 

624: // make up a metaclass for the Delphi System unit 

625: LMetaType := CreateMetaSubType (ABaseType, LNewType, LTypeBuilder 

) ; 

626: LMetaConstructor := LMetaType . GetConstructor ([]) ; 

627: if LMetaConstructor = nil then 

628: raise EProxyError . Create ( SCouldNotFindMetaConstructor ) ; 
629: 

630: // plug ourselves into the class delegator system so that our pr 
oxy 

type will 



// be found when someone does a Classlnfo on this type/metatype 
SetClassDelegator (LProxyType, LMetaConstructor . Invoke ([])); 

// add it to the list of known 'live' proxies 
FProxies . Add (LNewType, LMetaType) ; 

// return the proxy type 
Result := LProxyType; 
end; 

class procedure TProxyType . Savelt ; 

begin 

// caution: this is a one shot thing! once you call this you can 

// create anymore proxy classes. 
FAssemblyBuilder . Save ( STestFileName) ; 
end; 



handed a 
651: // 

modify 
652: 



// if it is already a proxy then complain... if we have been 

proxytype, instead of a ' realtype * , then FindRealType will 
// AType so that it points to the proxy's UnderlyingSystemType 



653 
654 
655 
656 
657 



if FindRealType (AType) then 

raise EProxyError . Create ( SAlreadyProxy) ; 



// add the delegator 

SetClassDelegator (TProxyType . Create (AType, AType .Name, 
AType . Namespace) ) ; 

658 : 

659: // add it the proxy list 

660 : FProxies .Add (AType, TypeOf (TClass (AType) ) ) ; 
661 : end; 
662 : 

663: class procedure TProxyType . DestroySubType (AType : System. Type) ; 

6 64: begin 

665: // is it really subtyped? if so then complain loudly... if we 

have been 

666: // handed a proxytype, instead of a ' realtype ' , then FindRealT 

ype 
will 

667: // modify AType so that it points to the proxy's 
UnderlyingSystemType . 
668: if not FindRealType (AType) then 
669: raise EProxyError . Create ( STypeNotSubType) ; 

670: 
671 : 
672: 
673: 
674 : 
675: 
676: 

677 : 

678 : 
679: 

680 : 

681 : 
nt 

the realtype) 



// remove it from the proxy list 
FProxies . Remove (AType) ; 

// remove the delegator 
RemoveClassDelegator (AType) ; 
end; 

class procedure TProxyType . RenameSubType (AType : System. Type; 

const AClassName: string; const AUnitName : string = ' ') ; 
begin 

// is it really subtyped? (we call IsSubType because we don't wa 



682 
683 
684 
685 
686 
687 



if not IsSubTyped (AType) then 

raise EProxyError . Create ( STypeNotSubType) ; 

// change the name 

TProxyType (AType) . FClassName := AClassName; 
if AUnitName <> ' ' then 



688; 
689: 
690; 
691; 
e; 
692; 
693; 
694; 
695; 
696; 

697 : 

698 : 
699: 

700 : 

701 : 

702 : 
703: 
704 : 



end; 



TProxyType (AType) .FUnitName 



AUnitName; 



class function TProxyType . FindProxy (AInstance : TObject) : TProxyTyp 
var 

LType : System . Type ; 
begin 

// find the type 

LType := AInstance . Class Info ; 

// make sure it is what we need otherwise complain 
if not (LType is TProxyType) then 

raise EProxyError . Create (STypeNotSubType) ; 
Result := TProxyType (LType) ; 
end; 

function TProxyType . CreateMethod ( const AMethodName : string): 



TMethodCode; 



705: 

706 : 

707 : 

708 : 
709: 
710: 
711: 
712 : 
713: 
714 : 
715: 
716: 
717 : 

const 
718 
719 
720 
721 
722 
723 
724 
725 
726 
727 
728 
729 

' 730: 
731: 
732: 
733: 
734: 
735: 
736: 

737 : 

738 : 

739 : 

740 : 
AName 

741 
742 
743 
744 
745 
746 
747 
748 
749 
750 



var 

LMethodCode : TMethodCode ; 

begin 

LMethodCode := TMethodProxy (FMet hods [AMethodName] ) ; 

if LMethodCode = nil then 

begin 

LMethodCode := TMethodProxy . Create ( Self , AMethodName) 
FMet hods .Add (AMethodName, LMethodCode) ; 
end; 

Result := LMethodCode; 
end; 



TMethodCode; 



procedure TProxyType . RenameMethod (const AMethodCode : 

AMethodName: string) ; 
begin 

/ / make sure it is a method proxy 

if not (AMethodCode is TMethodProxy) then 

raise EProxyError . Create ( SMethodNotMethodProxy) ; 

// remove, rename and re-add 
FMethods . Remove (AMethodCode . Name ) ; 
TMethodProxy (AMethodCode) .Rename (AMethodName) ; 
FMethods .Add (AMethodName, AMethodCode) ; 
end; 

procedure TProxyType . DestroyMethod (const AMethodCode: TMethodCode) 
begin 

// make sure it is a method proxy 

if not (AMethodCode is TMethodProxy) then 

raise EProxyError . Create ( SMethodNotMethodProxy) ; 

// remove and clear 

FMethods . Remove (AMethodCode . Name) ; 
TMethodProxy (AMethodCode) .Clear; 
end; 

class function TProxyType . GetMethodAddress (AClass : TClass; const 
: string; out ACode : TMethodCode) : Boolean; 

var 

LType: System. Type; 
begin 

// assume failure 
ACode : = nil; 

// find the class' type 
LType := AClass . Classlnfo; 
Result := LType is TProxyType; 
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7 
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7 

AP 
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14 
15 
16 



// keep looking but only if the type is a TProxyType 

while LType is TProxyType do 

begin 

// see if there is a method 

ACode := TMethodCode (TProxyType (LType) . FMethods . Item [AName] ) ; 
if ACode <> nil then 
break; 

// still nothing? then look at the parent class 
AClass := AClass . ClassParent ; 
LType := AClass . Classlnfo; 
end; 
end; 

class function TProxyType . GetMethodProp (AInstance : TObject; 
nfo: TPropInfo; out AMethod: TMethod) : Boolean; 

var 

LInstanceRef : TInstanceRef ; 
LMethodRef : TObject; 
begin 

// find the instance 

LInstanceRef := TInstanceRef (FInstances . Item [AInstance] ) ; 
Result := LInstanceRef <> nil; 

// do our thing? 
if Result then 
begin 

// find the property 

LMethodRef := LInstanceRef . Props . Item [APropInfo] ; 

// if nothing 

if LMethodRef = nil then 

AMethod : = TMethod . Empty 
else 

AMethod := TMethod (LMethodRef ) ; 

// I guess it worked 
Result := True; 
end; 
end; 

class function TProxyType . SetMethodProp (AInstance : TObject; 

nfo: TPropInfo; const AMethod: TMethod) : Boolean; 

var 

LInstanceRef: TInstanceRef; 
begin 

// something we care about? 

Result := (AMethod. Data = nil) or IsProxyClass (AMethod . Data) ; 

if Result then 

begin 

// find the instance 

LInstanceRef := TInstanceRef (FInstances . Item [AInstance] ) ; 

if LInstanceRef = nil then 
begin 

LInstanceRef := TInstanceRef . Create; 
FInstances .Add (AInstance, LInstanceRef) ; 

end; 

// adding? 

if not AMethod . I sEmpty then 

LInstanceRef . Props [APropInfo] := AMethod . Clone 

// removing? 

else 

begin 



817: // poof! 

818 : LInstanceRef . Props . Remove (APropInf o) ; 

819: 

820: // if there are no props defined then get rid of the instanc 

e 

itself 

821: if LInstanceRef . Props . Count = 0 then 

822 : FInstances . Remove (AInstance) ; 

823: end; 

824: end; 

82 5: end; 

826: 

827: class function TProxyType . GetUnitName (ATypelnf o : TTypelnfo; out 

AUnitName: string) : Boolean; 
82 8: begin 

829: // assume success 
830: Result := True; 
831 : 

832: // go find the right type and get its proxy, if there is one 
833: AUnitName := TClass (ATypelnf o) . Classlnfo . NameSpace; 
8 34: end; 
835: 

836: class procedure TProxyType . HandleNot if icat ion ( Sender : TObject; 
AComponent : TComponent; Operation: TOperation) ; 
837: begin 

838: // remove it from our list 
839: if Operation = opRemove then 

84 0: TProxyType .FInstances .Remove (AComponent) ; 

841: end; 

842: 

843: { TMethodProxy } 
844 : 

845: constructor TMethodProxy . Create (AProxyType : TProxyType; const ANam 
e : 

string) ; 
846: begin 

847: inherited Create; 

848: FProxyType := AProxyType; 

8 4 9: FName : = AName ; 

8 50: end; 

851 : 

8 52: procedure TMethodProxy . Clear; 
853: begin 

854: FProxyType := nil; 
855: FName := ' ' ; 
856: end; 
857: 

858: procedure TMethodProxy . Rename (Value : string); 
859: begin 

8 60: FName := Value; 

861: end; 

862: 

8 63: function TMethodProxy . get_ProxyType : TProxyType; 

8 64: begin 

8 65: Result := FProxyType; 
866: end; 
867 : 

868: function TMethodProxy . GetCustomAttributes (AInherit : Boolean): 
TOb jects; 
869: begin 

870: Result := GetCustomAttributes (nil, AInherit); 
871: end; 
872 : 

873: function TMethodProxy . GetCustomAttributes (AttributeType : System. Ty 
pe; 

Inherit: Boolean) : TOb jects; 
874: begin 

875: SetLength (Result, 0); 



876: end; 
877: 

878: function TMethodProxy . IsDef ined (AttributeType : System. Type; Inheri 
t : 

Boolean) : Boolean; 

87 9: begin 

880: Result : = False; 

8 81: end; 

882: 

883: function TMethodProxy . get_DeclaringType : System. Type; 

884: begin 

885: Result := FProxyType; 

886: end; 
887 : 

888: function TMethodProxy . get_MemberType : MemberTypes; 

88 9: begin 

8 90: Result := MemberTypes .Method; 

8 91: end; 
892 : 

8 93: function TMethodProxy . get_Name : string; 

894: begin 

8 95: Result := FName; 

8 96: end; 
897 : 

8 98: function TMethodProxy . get_Ref lectedType : System. Type; 

8 99: begin 

900: Result := nil; 

901: end; 

902: 

903: { Unit functions } 
904 : 

905: function CreateSubClass (AAncestor : TClass; const AClassName: strin 

g; 

906: const AUnitName : string) : TClass; 

907: begin 

90 8 : Result := TClass (TProxyType . CreateSubType (AAncestor . Class Info, 
AClassName, AUnitName) ) ; 
90 9: end; 
910 : 

911: resourcestring 

912: SNoValidConstructor = 'No valid constructor found for %s . ' ; 
913: 

914: function Construct Subclass (AClass : TClass; AParams: array of 
TObject) : TObject; 
915 
916 
917 
918 
919 
920 
921 
922 
923 
924 
925 
fo; 
926 
927 
928 



var 

LParameterNdx : Integer; 
LParamTypes: array of System. Type; 
LConstructor : Constructorinf o; 
begin 

SetLength (LParamTypes, Length (AParams ) ) ; 

for LParameterNdx := Low (AParams) to High (AParams) do 

if AParams [LParameterNdx] = nil then 

LParamTypes [LParameterNdx] := TypeOf (TObject ) 

else 

LParamTypes [LParameterNdx] := AParams [LParameterNdx] . Classin 



LConstructor := AClass . Classlnfo . GetConstructor (LParamTypes ) ; 
if LConstructor = nil then 

raise EProxyError . CreateFmt (SNoValidConstructor, 
[AClass . ClassName] ) ; 
92 9: Result := LConstructor . Invoke (AParams ) 
930: end; 
931 : 

932: function ConstructComponent (AClass : TComponentClass ; AOwner: 
TComponent = nil) : TComponent; 
933: var 

934: LParamTypes: array of System. Type; 
935: LConstructor: Constructorinf o; 



936: begin 

937: //Result := AClass . Create (AOwner) ; // Corbin note: we need this to 



work 
938 
939 
940 
941 
942 
943 
944 
945 
946 
947 
948 
949 
950 
951 
952 
953 
954 



, . soon 

//Exit; 

SetLength (LParamTypes, 1); 

LParamTypes [ 0 ] := Typeinf o (TComponent ) ; 

LConstructor := AClass . Classlnfo . GetConstructor (LParamTypes ) ; 

if LConstructor = nil then 

begin 

{ Try a parameterless constructor } 
SetLength (LParamTypes, 0); 

LConstructor := AClass . Classlnfo . GetConstructor (LParamTypes ) ; 

if LConstructor <> nil then 
begin 

Result := TComponent (LConstructor . Invoke ([])) ; 
if AOwner <> nil then 

AOwner . InsertComponent (Result) ; 

end 
else 

raise EProxyError . CreateFmt ( SNoValidConstructor, 



[AClass . ClassName] ) ; 



955 
956 
957 
958 
959 
960 
961 
962 
963 
964 
965 
966 
967 
968 
969 
970 



end 
else 

Result := TComponent (LConstructor. Invoke ( [AOwner] ) ) 

end; 

procedure DestroySubClass (AInstance : TObject) ; 
begin 

DestroySubClass (AInstance . ClassType) ; 
end; 

procedure DestroySubClass (AClass : TClass); 
begin 

TProxyType . DestroySubType (AClass . Classlnfo) ; 
end; 



procedure RenameSubClass (AInstance : TObject; const AClassName, 

AUnitName: string) ; 
971: begin 

972: RenameSubClass (AInstance . ClassType, AClassName, AUnitName); 
97 3: end; 
974 : 

975: procedure RenameSubClass (AClass : TClass; const AClassName, AUnitNa 
me : 

string) ; 
976: begin 

977: TProxyType . RenameSubType (AClass . Classlnfo, AClassName, AUnitName 

) ; 

97 8: end; 
979: 

980: function IsProxyClass (AInstance : TObject): Boolean; 
981: begin 
982: Result 
9 83: end; 

984 : 
985 
986 
987 



IsProxyClass (AInstance . ClassType ) ; 



function IsProxyClass (AClass : TClass): Boolean; 

begin 

Result := TProxyType . IsSubTyped (AClass . Classlnfo) ; 
988: end; 

989 : 

990 : 

991 : 

992 : 
993: 
994 : 

9 95: procedure ChangeToProxyClass (AClass : TClass); 
9 96: begin 



procedure ChangeToProxyClass (AInstance : TObject); 
begin 

ChangeToProxyClass (AInstance . ClassType) ; 
end; 



997 : TProxyType . ChangeToProxyType (AClass . Classinf o) ; 

9 98: end; 

999: 

1000: function CreateSubClassMethod (AInstance : TObject; const AMethodNam 
e : 

string) : TMethodCode; 

10 01: begin 

1002: Result := TProxyType . FindProxy (AInstance) . CreateMethod (AMethodNa 
me) ; 

1003: end; 
1004 : 

1005: procedure RenameSubClassMethod (AInstance : TObject; const AMethodCo 
de: 

TMethodCode; const AMethodName : string); 

1006: begin 

10 07: TProxyType . FindProxy (AInstance) . RenameMethod (AMethodCode, 
AMethodName) ; 

1008: end; 
1009 : 

1010: procedure DestroySubClassMethod (AInstance : TObject; const 
AMethodCode: TMethodCode) ; 

1011: begin 

1012: TProxyType .FindProxy (AInstance) . DestroyMethod (AMethodCode) ; 

1013: end; 

1014: 

1015: procedure HandleNot if icat ion ( Sender : TObject; AComponent : TCompone 
nt ; 

Operation: TOperation) ; 

1016: begin 

1017: TProxyType .HandleNotif icat ion (Sender, AComponent, Operation); 

1018: end; 

1019 : 

1020: procedure Savelt; 

1021: begin 

1022 : TProxyType . Savelt; 

1023: end; 
1024 : 

1025: end. 



